home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_lfl.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  12.6 KB  |  435 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_lfl.c */
  5.  
  6. #include "clos.h"
  7.  
  8. #define PHASE_PARAM     0
  9. #define PHASE_OPTIONAL    1
  10. #define PHASE_REST      2
  11. #define PHASE_REST_1    3
  12. #define PHASE_REST_2    4
  13. #define PHASE_KEY       5
  14. #define PHASE_AUX       6
  15.  
  16.  
  17. void lambda_eval(ufunc,param,nout,genv,lenv,ev_fl)
  18. node ufunc;
  19. node param;
  20. node_p *nout;
  21. node genv;
  22. node lenv;
  23. unsigned ev_fl;
  24. {
  25.  /* valutazione di una lambda */
  26.  /* param sono i parametri attuali della lambda gia' valutati */
  27.  
  28.  node     ufunc_par=UFUNC_PAR(ufunc);
  29.  node   new_lenv=UFUNC_ENV(ufunc);
  30.  node    new_genv=genv;
  31.  int     phase=PHASE_PARAM;
  32.  node     parlist=param;
  33.  node   name;
  34.  node   value;
  35.  node     tmp;
  36.  
  37.  /*   new_lenv  e'  il nuovo environment della lambda : e'una A-list       */
  38.  /*   new_genv  e' il nuovo environment di DEFVAR */
  39.  
  40.  for(;;){
  41.   /* lo scopo si questo switch e' quello di assegnare alle 2 variabili */
  42.   /* name e value il nome e il valore riferiti al parametro corrente */
  43.   /* alla fine dello switch nome e valore verranno  messi insieme */
  44.   switch(phase){
  45.     case PHASE_PARAM:
  46.       if(IS_CONS(ufunc_par)){ /* ufunc_par=( n1 n2 ... nn ) */
  47.     if(IS_CONS(parlist)){
  48.       /* ok c'e' il parametro */
  49.       name=CONSLEFT(ufunc_par);
  50.       value=CONSLEFT(parlist);
  51.       ufunc_par=CONSRIGHT(ufunc_par);
  52.       parlist=CONSRIGHT(parlist);
  53.       break;
  54.     }
  55.     /* non c'e' il parametro */
  56.     error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,¶m);
  57.       }
  58.       ufunc_par=UFUNC_OPT(ufunc);
  59.       phase=PHASE_OPTIONAL;
  60.  
  61.     case PHASE_OPTIONAL:
  62.       if(IS_CONS(ufunc_par)){
  63.         /* ufunc_par= ( (n1 . v1) (n2 . v2) ... (nn . vn)) */
  64.     name=CONSLEFT(ufunc_par); /* name = (n1 . v1) */
  65.     if(IS_CONS(parlist)){
  66.       name=CONSLEFT(name);
  67.       value=CONSLEFT(parlist);
  68.       parlist=CONSRIGHT(parlist);
  69.       ufunc_par=CONSRIGHT(ufunc_par);
  70.       break;
  71.     }
  72.     eval(CONSRIGHT(name),nout,genv,lenv,EVAL_NORM);
  73.     value=calc_pointer(nout);
  74.     name=CONSLEFT(name);
  75.     ufunc_par=CONSRIGHT(ufunc_par);
  76.     break;
  77.       }
  78.       ufunc_par=UFUNC_REST(ufunc);
  79.       phase=PHASE_REST;
  80.  
  81.     case PHASE_REST:
  82.       /* ufunc par e' nil o un nome */
  83.       if(ufunc_par!=NIL){
  84.  
  85.     /* bisogna spezzare parlist fino a quando si trova un nodo CNAME':'*/
  86.     /* parlist e' uguale alla lista a partire dal primo nodo : */
  87.     /* value e' il pezzo prima di parlist */
  88.     value=tmp=parlist;
  89.     name=NIL;/*previous*/
  90.     while(IS_CONS(tmp)){
  91.       if(IS_VALUE(CONSLEFT(tmp))&&GET_VTYPE(CONSLEFT(tmp))==NT_CNAME){
  92.             if(name!=NIL){
  93.               CONSRIGHT(name)=NIL;
  94.               parlist=tmp;
  95.             }else{
  96.               value=NIL;
  97.               /* e parlist non si tocca */
  98.             }
  99.             break;
  100.           }
  101.           name=tmp;/*previous*/
  102.           tmp=CONSRIGHT(tmp);
  103.         }
  104.         if(!IS_CONS(tmp))parlist=NIL;
  105.         name=ufunc_par;
  106.         ufunc_par=UFUNC_KEY(ufunc);
  107.         phase=PHASE_KEY;
  108.         break; /* il giro dopo si passa comunque a PHASE_KEY */
  109.       }
  110.       ufunc_par=UFUNC_KEY(ufunc);
  111.       phase=PHASE_KEY;
  112.  
  113.     case PHASE_KEY:
  114.       /*printf("\nPHASE KEY:parlist=");fprint_func(parlist,stdout); */
  115.       if(IS_CONS(parlist)){
  116.         name=CONSLEFT(parlist);
  117.         /* name deve essere :NOME */
  118.         if(IS_VALUE(name)&&GET_VTYPE(name)==NT_CNAME&&
  119.            IS_NAME(CNAME(name))&&HAS_NAME(CNAME(name))){
  120.           name=CNAME(name);
  121.           if(IS_CONS(parlist=CONSRIGHT(parlist))){
  122.             value=CONSLEFT(parlist);
  123.             /* si cerca name nella ufunc-par */
  124.             /* se lo si trova si marca ufunc-par e si assegna */
  125.             tmp=ufunc_par;
  126.             while(IS_CONS(tmp)){
  127.               if(CONSLEFT(CONSLEFT(tmp))==name){
  128.                 REM(CONSLEFT(tmp));      
  129.                 break;
  130.           }
  131.               tmp=CONSRIGHT(tmp);
  132.             }
  133.             /* qui' se si e' trovato name nella ufunc_par tmp e' un cons */
  134.             /* che tra l'altro e' REM altrimenti tmp e' NIL */
  135.          if(!IS_CONS(tmp)){
  136.           while(IS_CONS(ufunc_par)){
  137.                 UNREM(ufunc_par);
  138.                 ufunc_par=CONSRIGHT(ufunc_par);
  139.               } 
  140.               error(E_TOOMANYARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&name);
  141.             }
  142.             parlist=CONSRIGHT(parlist);
  143.             break; /* si assegna: name=value */
  144.           }
  145.           while(IS_CONS(ufunc_par)){
  146.             UNREM(ufunc_par);
  147.             ufunc_par=CONSRIGHT(ufunc_par);
  148.           } 
  149.           error(E_FEWARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,¶m);
  150.     }
  151.         while(IS_CONS(ufunc_par)){
  152.           UNREM(ufunc_par);
  153.           ufunc_par=CONSRIGHT(ufunc_par);
  154.     }
  155.         error(E_TOOMANYARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,¶m);
  156.       }
  157.       /* qui' ci si arriva solo se parlist e' finita o e' vuota */
  158.       HalfWhile:
  159.       if(IS_CONS(ufunc_par)){
  160.         tmp=CONSLEFT(ufunc_par);
  161.         ufunc_par=CONSRIGHT(ufunc_par);
  162.         if(IS_REM(tmp)){
  163.           UNREM(tmp);
  164.           goto HalfWhile;
  165.         }
  166.         name=CONSLEFT(tmp);
  167.         eval(CONSRIGHT(tmp),nout,genv,lenv,EVAL_NORM);
  168.     value=calc_pointer(nout);
  169.     break;
  170.       }
  171.       ufunc_par=UFUNC_AUX(ufunc);
  172.       phase=PHASE_AUX;
  173.  
  174.     case PHASE_AUX:
  175.       if(IS_CONS(ufunc_par)){
  176.     name=CONSLEFT(ufunc_par);
  177.     eval(CONSRIGHT(name),nout,genv,lenv,EVAL_NORM);
  178.     value=calc_pointer(nout);
  179.     name=CONSLEFT(name);
  180.     ufunc_par=CONSRIGHT(ufunc_par);
  181.     break;
  182.       }
  183.  
  184.  
  185.      /* valutazione delle s-espressioni della lambda */
  186.      /* usando GlobalENVironment e NEW_LocalENVironment */
  187.      /* il flag di valutazione e' sempre EVAL_NORM tranne per */
  188.      /* l'ultima s-espressione che lo ha settato a ev_fl */
  189.      /* ev_fl e' uno dei parametri passati all' inizio. */
  190.      /* nota: UFUNC_SEX(ufunc) e' sicuramente un CONS. */
  191.  
  192.      /* si costruisce la lista del nuovo local-environment */
  193.  
  194.      ufunc_par=UFUNC_SEX(ufunc);
  195.      /* vedere se e' il caso di ripulire i nodi che sono stati */
  196.      /* usati per creare l'environment */
  197.      /* NB: ufunc_par non e' mai NIL ma contiene almeno 1 cons */
  198.      while(IS_CONS(CONSRIGHT(ufunc_par))){
  199.         eval(CONSLEFT(ufunc_par),nout,new_genv,new_lenv,EVAL_NORM);
  200.         ufunc_par=CONSRIGHT(ufunc_par);
  201.      }
  202.      eval(CONSLEFT(ufunc_par),nout,new_genv,new_lenv,ev_fl);
  203.      return;
  204.  
  205.   }/* switch phase */
  206.  
  207.   /* fase di assegnamento del valore VALUE all' atomo NAME       */
  208.   internal_update_environment(name,value,&new_genv,&new_lenv);
  209.  }/* for(;;) */
  210. }
  211.  
  212.  
  213.  
  214. void macro_eval(ufunc,param,nout,genv,lenv,ev_fl)
  215. node ufunc;
  216. node param;
  217. node_p *nout;
  218. node genv;
  219. node lenv;
  220. unsigned ev_fl;
  221. {
  222.  /* valutazione di una macro */
  223.  /* Φ identica alla lambda solo che si crea un environment locale appendendo
  224.     quello della lambda a quello giα esistente */
  225.     /* in questo modo si ottiene un comportamento equivalente alla sostituzione lessicale
  226.        della macro nel contesto ove viene usata. */
  227.  /* param sono i parametri attuali della lambda gia' valutati */
  228.  
  229.  
  230.  node     ufunc_par=UFUNC_PAR(ufunc);
  231.  node   new_lenv=UFUNC_ENV(ufunc);
  232.  node    new_genv=genv;
  233.  int     phase=PHASE_PARAM;
  234.  node     parlist=param;
  235.  node   name;
  236.  node   value;
  237.  node     tmp;
  238.  node    last_ufuncenv;
  239.  
  240.  /*   new_lenv  e'  il nuovo environment della lambda : e'una A-list       */
  241.  /*   new_genv  e' il nuovo environment di DEFVAR */
  242.  
  243.  
  244.  last_ufuncenv=tmp=UFUNC_ENV(ufunc);
  245.  while(IS_CONS(tmp)){
  246.    last_ufuncenv=tmp;
  247.    tmp=CONSRIGHT(tmp);
  248.  }
  249.  if(last_ufuncenv==NIL){
  250.    new_lenv=lenv;
  251.  }else{
  252.    CONSRIGHT(last_ufuncenv)=lenv;
  253.    new_lenv=UFUNC_ENV(ufunc);
  254.  }
  255.  
  256.  
  257.  
  258.  for(;;){
  259.   /* lo scopo si questo switch e' quello di assegnare alle 2 variabili */
  260.   /* name e value il nome e il valore riferiti al parametro corrente */
  261.   /* alla fine dello switch nome e valore verranno  messi insieme */
  262.   switch(phase){
  263.     case PHASE_PARAM:
  264.       if(IS_CONS(ufunc_par)){
  265.     if(IS_CONS(parlist)){
  266.           /* ok c'e' il parametro */
  267.           name=CONSLEFT(ufunc_par);
  268.       value=CONSLEFT(parlist);
  269.       ufunc_par=CONSRIGHT(ufunc_par);
  270.           parlist=CONSRIGHT(parlist);
  271.           break;
  272.     }
  273.     /* non c'e' il parametro */
  274.         error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,¶m);
  275.       }
  276.       ufunc_par=UFUNC_OPT(ufunc);
  277.       phase=PHASE_OPTIONAL;
  278.  
  279.     case PHASE_OPTIONAL:
  280.       if(IS_CONS(ufunc_par)){
  281.     name=CONSLEFT(ufunc_par);
  282.         if(IS_CONS(parlist)){
  283.           name=CONSLEFT(name);
  284.           value=CONSLEFT(parlist);
  285.           parlist=CONSRIGHT(parlist);
  286.           ufunc_par=CONSRIGHT(ufunc_par);
  287.           break;
  288.         }
  289.         eval(CONSRIGHT(name),nout,genv,lenv,EVAL_NORM);
  290.     value=calc_pointer(nout);
  291.         name=CONSLEFT(name);
  292.         ufunc_par=CONSRIGHT(ufunc_par);
  293.         break;
  294.       }
  295.       ufunc_par=UFUNC_REST(ufunc);
  296.       phase=PHASE_REST;
  297.  
  298.     case PHASE_REST:
  299.       /* ufunc par e' nil o un nome */
  300.       if(ufunc_par!=NIL){
  301.  
  302.         /* bisogna spezzare parlist fino a quando si trova un nodo CNAME':'*/
  303.         /* parlist e' uguale alla lista a partire dal primo nodo : */
  304.         /* value e' il pezzo prima di parlist */
  305.         value=tmp=parlist;
  306.         name=NIL;/*previous*/
  307.         while(IS_CONS(tmp)){
  308.           if(IS_VALUE(CONSLEFT(tmp))&&GET_VTYPE(CONSLEFT(tmp))==NT_CNAME){
  309.             if(name!=NIL){
  310.           CONSRIGHT(name)=NIL;
  311.               parlist=tmp;
  312.             }else{
  313.           value=NIL;
  314.           /* e parlist non si tocca */
  315.             }
  316.             break;
  317.       }
  318.       name=tmp;/*previous*/
  319.           tmp=CONSRIGHT(tmp);
  320.         }
  321.         if(!IS_CONS(tmp))parlist=NIL;
  322.     name=ufunc_par;
  323.         ufunc_par=UFUNC_KEY(ufunc);
  324.         phase=PHASE_KEY;
  325.         break; /* il giro dopo si passa comunque a PHASE_KEY */
  326.       }
  327.       ufunc_par=UFUNC_KEY(ufunc);
  328.       phase=PHASE_KEY;
  329.  
  330.     case PHASE_KEY:
  331.       /*printf("\nPHASE KEY:parlist=");fprint_func(parlist,stdout); */
  332.       if(IS_CONS(parlist)){
  333.         name=CONSLEFT(parlist);
  334.         /* name deve essere :NOME */
  335.     if(IS_VALUE(name)&&GET_VTYPE(name)==NT_CNAME&&
  336.            IS_NAME(CNAME(name))&&HAS_NAME(CNAME(name))){
  337.           name=CNAME(name);
  338.           if(IS_CONS(parlist=CONSRIGHT(parlist))){
  339.             value=CONSLEFT(parlist);
  340.             /* si cerca name nella ufunc-par */
  341.             /* se lo si trova si marca ufunc-par e si assegna */
  342.             tmp=ufunc_par;
  343.             while(IS_CONS(tmp)){
  344.               if(CONSLEFT(CONSLEFT(tmp))==name){
  345.                 REM(CONSLEFT(tmp));      
  346.                 break;
  347.           }
  348.               tmp=CONSRIGHT(tmp);
  349.             }
  350.             /* qui' se si e' trovato name nella ufunc_par tmp e' un cons */
  351.             /* che tra l'altro e' REM altrimenti tmp e' NIL */
  352.          if(!IS_CONS(tmp)){
  353.               while(IS_CONS(ufunc_par)){
  354.                 UNREM(ufunc_par);
  355.         ufunc_par=CONSRIGHT(ufunc_par);
  356.               } 
  357.               error(E_TOOMANYARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&name);
  358.         }
  359.         parlist=CONSRIGHT(parlist);
  360.             break; /* si assegna: name=value */
  361.           }
  362.       while(IS_CONS(ufunc_par)){
  363.         UNREM(ufunc_par);
  364.             ufunc_par=CONSRIGHT(ufunc_par);
  365.           } 
  366.           error(E_FEWARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,¶m);
  367.     }
  368.     while(IS_CONS(ufunc_par)){
  369.           UNREM(ufunc_par);
  370.           ufunc_par=CONSRIGHT(ufunc_par);
  371.     }
  372.         error(E_TOOMANYARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,¶m);
  373.       }
  374.       /* qui' ci si arriva solo se parlist e' finita o e' vuota */
  375.       HalfWhile:
  376.       if(IS_CONS(ufunc_par)){
  377.         tmp=CONSLEFT(ufunc_par);
  378.         ufunc_par=CONSRIGHT(ufunc_par);
  379.         if(IS_REM(tmp)){
  380.       UNREM(tmp);
  381.           goto HalfWhile;
  382.         }
  383.         name=CONSLEFT(tmp);
  384.         eval(CONSRIGHT(tmp),nout,genv,lenv,EVAL_NORM);
  385.         value=calc_pointer(nout);
  386.         break;
  387.       }
  388.       ufunc_par=UFUNC_AUX(ufunc);
  389.       phase=PHASE_AUX;
  390.  
  391.     case PHASE_AUX:
  392.       if(IS_CONS(ufunc_par)){
  393.     name=CONSLEFT(ufunc_par);
  394.     eval(CONSRIGHT(name),nout,genv,lenv,EVAL_NORM);
  395.     value=calc_pointer(nout);
  396.     name=CONSLEFT(name);
  397.     ufunc_par=CONSRIGHT(ufunc_par);
  398.     break;
  399.       }
  400.  
  401.  
  402.      /* valutazione delle s-espressioni della lambda */
  403.      /* usando GlobalENVironment e NEW_LocalENVironment */
  404.      /* il flag di valutazione e' sempre EVAL_NORM tranne per */
  405.      /* l'ultima s-espressione che lo ha settato a ev_fl */
  406.      /* ev_fl e' uno dei parametri passati all' inizio. */
  407.      /* nota: UFUNC_SEX(ufunc) e' sicuramente un CONS. */
  408.  
  409.      /* si costruisce la lista del nuovo local-environment */
  410. /* lenv-modifica */
  411.  
  412.      ufunc_par=UFUNC_SEX(ufunc);
  413.      /* vedere se e' il caso di ripulire i nodi che sono stati */
  414.      /* usati per creare l'environment */
  415.      /* NB: non e' mai NIL ma contiene almeno 1 cons */
  416.      while(IS_CONS(CONSRIGHT(ufunc_par))){
  417.         eval(CONSLEFT(ufunc_par),nout,new_genv,new_lenv,EVAL_NORM);
  418.         ufunc_par=CONSRIGHT(ufunc_par);
  419.      }
  420.      eval(CONSLEFT(ufunc_par),nout,new_genv,new_lenv,ev_fl);
  421.      /** variazione macro ***/
  422.      if(last_ufuncenv!=NIL)CONSRIGHT(last_ufuncenv)=NIL;
  423.      return;
  424.  
  425.   }/* switch phase */
  426.  
  427.   /* fase di assegnamento del valore VALUE all' atomo NAME       */
  428.   internal_update_environment(name,value,&new_genv,&new_lenv);
  429.  }/* for(;;) */
  430. }
  431.  
  432.  
  433.  
  434.  
  435.